home *** CD-ROM | disk | FTP | other *** search
/ Atari Mega Archive 1 / Atari Mega Archive - Volume 1.iso / language / pcl_src.zoo / fsc.lsp < prev    next >
Lisp/Scheme  |  1992-07-09  |  5KB  |  134 lines
  1. ;;;-*-Mode:LISP; Package:(PCL LISP 1000); Base:10; Syntax:Common-lisp -*-
  2. ;;;
  3. ;;; *************************************************************************
  4. ;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation.
  5. ;;; All rights reserved.
  6. ;;;
  7. ;;; Use and copying of this software and preparation of derivative works
  8. ;;; based upon this software are permitted.  Any distribution of this
  9. ;;; software or derivative works must comply with all applicable United
  10. ;;; States export control laws.
  11. ;;; 
  12. ;;; This software is made available AS IS, and Xerox Corporation makes no
  13. ;;; warranty about the software, its performance or its conformity to any
  14. ;;; specification.
  15. ;;; 
  16. ;;; Any person obtaining a copy of this software is requested to send their
  17. ;;; name and post office or electronic mail address to:
  18. ;;;   CommonLoops Coordinator
  19. ;;;   Xerox PARC
  20. ;;;   3333 Coyote Hill Rd.
  21. ;;;   Palo Alto, CA 94304
  22. ;;; (or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa)
  23. ;;;
  24. ;;; Suggestions, comments and requests for improvements are also welcome.
  25. ;;; *************************************************************************
  26. ;;;
  27. ;;; This file contains the definition of the FUNCALLABLE-STANDARD-CLASS
  28. ;;; metaclass.  Much of the implementation of this metaclass is actually
  29. ;;; defined on the class STD-CLASS.  What appears in this file is a modest
  30. ;;; number of simple methods related to the low-level differences in the
  31. ;;; implementation of standard and funcallable-standard instances.
  32. ;;;
  33. ;;; As it happens, none of these differences are the ones reflected in
  34. ;;; the MOP specification; STANDARD-CLASS and FUNCALLABLE-STANDARD-CLASS
  35. ;;; share all their specified methods at STD-CLASS.
  36. ;;; 
  37. ;;; 
  38. ;;; workings of this metaclass and the standard-class metaclass.
  39. ;;; 
  40.  
  41. (in-package 'pcl)
  42.  
  43. (defmethod wrapper-fetcher ((class funcallable-standard-class))
  44.   'fsc-instance-wrapper)
  45.  
  46. (defmethod slots-fetcher ((class funcallable-standard-class))
  47.   'fsc-instance-slots)
  48.  
  49. (defmethod raw-instance-allocator ((class funcallable-standard-class))
  50.   'allocate-funcallable-instance-1)
  51.  
  52. ;;;
  53. ;;;
  54. ;;;
  55.  
  56. (defmethod validate-superclass
  57.        ((fsc funcallable-standard-class)
  58.         (class standard-class))
  59.   t) ; was (null (wrapper-instance-slots-layout (class-wrapper class)))
  60.  
  61.  
  62. (defmethod allocate-instance
  63.        ((class funcallable-standard-class) &rest initargs)
  64.   (declare (ignore initargs))
  65.   (unless (class-finalized-p class) (finalize-inheritance class))
  66.   (let ((class-wrapper (class-wrapper class)))
  67.     (allocate-funcallable-instance
  68.       class-wrapper (wrapper-allocate-static-slot-storage-copy class-wrapper))))
  69.  
  70. (defmethod make-optimized-reader-method-function
  71.            ((class funcallable-standard-class)
  72.             generic-function
  73.             reader-method-prototype
  74.             slot-name)
  75.   (declare (ignore generic-function reader-method-prototype))
  76.   (make-funcallable-standard-instance-reader-method-function slot-name))
  77.  
  78. (defmethod make-optimized-writer-method-function
  79.            ((class funcallable-standard-class)
  80.             generic-function
  81.             writer-method-prototype
  82.             slot-name)
  83.   (declare (ignore generic-function writer-method-prototype))
  84.   (make-funcallable-standard-instance-writer-method-function slot-name))
  85.  
  86. (defmethod make-optimized-boundp-method-function
  87.            ((class funcallable-standard-class)
  88.             generic-function
  89.             boundp-method-prototype
  90.             slot-name)
  91.   (declare (ignore generic-function boundp-method-prototype))
  92.   (make-funcallable-standard-instance-boundp-method-function slot-name))
  93.  
  94. (defun make-funcallable-standard-instance-reader-method-function (slot-name)
  95.   (declare #.*optimize-speed*)
  96.   #'(lambda (instance)
  97.       (funcallable-standard-instance-slot-value instance slot-name)))
  98.  
  99. (defun make-funcallable-standard-instance-writer-method-function (slot-name)
  100.   (declare #.*optimize-speed*)
  101.   #'(lambda (nv instance)
  102.       (setf (funcallable-standard-instance-slot-value instance slot-name) nv)))
  103.  
  104. (defun make-funcallable-standard-instance-boundp-method-function (slot-name)
  105.   (declare #.*optimize-speed*)
  106.   #'(lambda (instance)
  107.       (funcallable-standard-instance-slot-boundp instance slot-name)))
  108.  
  109. ;;;;
  110. ;;;; See the comment about reader-function--std and writer-function--sdt.
  111. ;;;;
  112. ;(define-function-template reader-function--fsc () '(slot-name)
  113. ;  `(function
  114. ;     (lambda (instance)
  115. ;       (slot-value-using-class (wrapper-class (get-wrapper instance))
  116. ;                   instance
  117. ;                   slot-name))))
  118. ;
  119. ;(define-function-template writer-function--fsc () '(slot-name)
  120. ;  `(function
  121. ;     (lambda (nv instance)
  122. ;       (setf
  123. ;     (slot-value-using-class (wrapper-class (get-wrapper instance))
  124. ;                 instance
  125. ;                 slot-name)
  126. ;     nv))))
  127. ;
  128. ;(eval-when (load)
  129. ;  (pre-make-templated-function-constructor reader-function--fsc)
  130. ;  (pre-make-templated-function-constructor writer-function--fsc))
  131.  
  132.  
  133.  
  134.